(** Standard Library Procedures *)

open Apost;;
open Utils;;


(** Calls procedures *)
let call stack globaldict c = match pop stack c with
    Procedure cs -> (
        try 
            List.iter (do_cmd stack globaldict) cs
        with APostReturn -> ()           (* Yes, this is deliberately a no-op *)
        )
  | ProcedureCatch (cs, es) -> (
        try 
            List.iter (do_cmd stack globaldict) cs
        with 
            APostReturn -> ()            (* Yes, this is deliberately a no-op *)
          | APostException l -> (
                try 
                    List.iter (do_cmd stack globaldict) es 
                with APostReturn -> ()      (* Once again, a deliberate no-op *)
                )
        )
  | _ -> raise_exception stack "Call commands require a Procedure on top of the stack." c
;;
let t1 = add_command "call" call;;                (* Hack to register the command*)
      
(** Sets key-value pairs in dictionaries *)
let set_dict stack globaldict c = 
    let d = pop stack c in
    let key = pop stack c in
    let value = pop stack c in
    match d with
        Dict env -> Hashtbl.add env key value
      | _ -> raise_exception stack "Argument type mismatch, Dictionary operations require a Dictionary on top of the stack." c
;;
let t1 = add_command "set_dict" set_dict;;                (* Hack to register the command*)

(** Gets values from dictionaries *)
let get_dict stack globaldict c = 
    let d = pop stack c in
    let key = pop stack c in
    match d with
        Dict env -> 
            (
            try
                push (Hashtbl.find env key) stack
            with Not_found -> raise_exception stack "Key not found in dictionary." c
            )
      | _ -> raise_exception stack "Argument type mismatch, Dictionary operations require a Dictionary on top of the stack." c
;;
let t1 = add_command "get_dict" get_dict;;                (* Hack to register the command*)

(** Prints strings *)
let print stack globaldict c = 
    match pop stack c with
        String s -> print_string s
      | _ -> raise_exception stack "Argument type mismatch, printing requires a String." c
;;
let t1 = add_command "print" print;;                (* Hack to register the command*)


let tostring stack globaldict c = 
    match pop stack c with
        String s -> push (String s) stack
      | Integer i -> push (String (string_of_int i)) stack
      | _ -> raise_exception stack "Argument type mismatch, only Numbers and Strings can be converted to Strings." c
;;
let t1 = add_command "tostring" tostring;;                (* Hack to register the command*)

(** Puts the global dictionary onto the stack *)
let global stack globaldict c = push (Dict globaldict) stack
;;
let t1 = add_command "global" global;;                (* Hack to register the command*)

(** Creates a new Dictionary *)
let new_dict stack globaldict c = push (Dict (Hashtbl.create 50)) stack
;;
let t1 = add_command "new_dict" new_dict;;                (* Hack to register the command*)

(** Runs a loop *)
let loop stack globaldict c = 
    let cond = pop stack c in
    let bs = 
        (
        match pop stack c with
            Procedure bs -> bs
          | _ -> raise_exception stack "Loop commands require a Procedure for the body of the loop." c;
                []              (* needed for the types to match, this is never executed *)
        ) in
    while exec_cond stack globaldict cond c do
        List.iter (do_cmd stack globaldict) bs
    done
;;
let t1 = add_command "loop" loop;;                (* Hack to register the command*)

let branch stack globaldict c = 
    let cond = pop stack c in
    let fs = 
        (
        match pop stack c with
            Procedure bs -> bs
          | _ -> raise_exception stack "Branch commands require a Procedure for the body." c; 
                []          (* needed for the types to match, this is never executed *)
        ) in
    let ts = 
        (
        match pop stack c with
            Procedure bs -> bs
          | _ -> raise_exception stack "Branch commands require a Procedure for the body." c; 
                []          (* needed for the types to match, this is never executed *)
        ) in
    if exec_cond stack globaldict cond c then
        List.iter (do_cmd stack globaldict) ts
    else
        List.iter (do_cmd stack globaldict) fs
;;
let t1 = add_command "branch" branch;;                (* Hack to register the command*)

let throw stack globaldict c = raise (APostException (get_lineno c));;
let t1 = add_command "throw" throw;;                (* Hack to register the command*)

let return stack globaldict c = raise APostReturn;;
let t1 = add_command "return" return;;                (* Hack to register the command*)

let _ = Hashtbl.iter (fun k v -> print_endline k) commands;;
